perm filename HOMX.OLD[NEW,LCS] blob
sn#502586 filedate 1980-03-29 generic text, type T, neo UTF8
00100 C HOMX, LULOOP, ZCRSOR, HELP, ORDER, DPYX, FILX
00200 C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
00300 SUBROUTINE HOMX
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RNW/RNW
00500 1 /POSI/STFF(0/7),JJ2,POS /LIMIT/LIMIT,ITEM,L,I,IX
00600 2 /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(1) /PTR/PWDS(1)
00700 3 /ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
00800 EQUIVALENCE (R3,RJQ(1)),(R7,RJQ(5)),(R9,RJQ(7))
00900 1,(R4,RJQ(2)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8))
01000
01100 JJ2=1000
01200 C THE STAFF # =R2
01300 DO 110 K=1,ITEM
01400 IF(CODN(K,L).NE.6)GO TO 110
01500 C RETURNS POINTER IN L
01600 C%%%%%%%%%%%
01700 IF(R2.GT.7)GO TO 10
01800 C J2=STAFF #. >7 = ALL STAVES.
01900 IF(RN(L+2).NE.R2)GO TO 110
02000 10 R7=RN(L+7)
02100 IF(R7)GO TO 110
02200 C SKIP TREMOLO AND UNATTACHED PARTIAL BEAMS.
02300 RS=RN(L+2)
02400 C STAFF OF THIS BEAM
02500 ISD=IFIX(R7/10.)
02600 C STEM DIRECTION. 1=UP 2=DOWN
02700 RM=RSTFAC(IFIX(RS))
02800 RSTJ2=RM
02900 C SIZE FACTOR
03000 RL=RN(L+3)
03100 RR=RN(L+6)
03200 C OVERALL LEFT-RIGHT LIMITS
03300 PL=RL
03400 PR=RR
03500 C LEFT-RIGHT POS. TO BE USED
03600 RLH=RN(L+4)
03700 RRH=RN(L+5)
03800 C LEFT-RIGHT HEIGHTS
03900 RMIN=1.
04000 MIN=-1
04100 C FLAG FOR MINI-NOTES AND BEAMS
04200 W=ABS(RLH)
04300 IF(W.LE.80)GO TO 20
04400 CCC IF(W.GE.180)GO TO 3
04500 C SKIP IF X NOTES, DIAMONDS, NO NOTE HEAD
04600 MIN=0
04700 RMIN=.6
04800 RM=RM*.6
04900 C MINI SIZE FACTOR
05000 RLH=ABS(RLH)-100.
05100 20 WC=RN(L)
05200 C WORD COUNT
05300 T=-1
05400 IF(RN(L+10).GE.100)GO TO 30
05500 C P10=100 ETC. =COMPOSITE BEAM WITH AT LEAST 1 COMPLETE ONE.
05600 IF(WC.LT.6)GO TO 30
05700 R8=RN(L+8)
05800 IF(R8.EQ.0)GO TO 30
05900 IF(R8)GO TO 110
06000 IF(WC.LT.7)GO TO 30
06100 R9=RN(L+9)
06200 IF(R9.EQ.0)GO TO 30
06300 PL=R8
06400 PR=R9
06500 C POS. OF INNER PARTIAL BEAM.
06600 IF(WC.LT.8)GO TO 30
06700 IF(RN(L+10).GT.0)T=RN(L+10)+T
06800 30 IR7=AMOD(R7,10.0)+T
06900 C NUMBER OF BEAMS
07000 PL=PL-.1
07100 PR=PR+.1
07200 C FOR ROUND-OFF ERROR
07300 T=RR-RL
07400 C TOTAL LENGTH OF FULL BEAM
07500 TH=RRH-RLH
07600 C TOTAL HEIGHT
07700 T=TH/T
07800 C FACTOR
07900
08000 DO 100 J=1,ITEM
08100 IF(CODN(J,L).NE.1)GO TO 100
08200 IF(RN(L+2).NE.RS)GO TO 100
08300 C SKIP IF NOT ON RIGHT STAFF
08400 R5=RN(L+5)
08500 IF(R5.LT.10)GO TO 100
08600 C SKIP IF NO STEM ON NOTE
08700 R3=RN(L+3)
08800 IXD=0
08900 CW A=0
09000 IF(IFIX(R5/10.).EQ.ISD)GO TO 40
09100 C A IS FOR HORZ. DISPLACEMENT DUE TO OPPOSITE STEM DIRECTIONS.
09200 IXD=-1
09300 A=RNW*RM
09400 C A=WIDTH OF NOTE*SIZE FACTOR + OR - RNW=WIDTH OF A NOTE(2.44)
09500 IF(ISD.EQ.1)A=-A
09600 R3=A+R3
09700 40 IF(R3.LT.PL)GO TO 100
09800 IF(R3.GT.PR)GO TO 100
09900 C SKIP IF NOT IN BOUNDS OF BEAM SEGMENT.
10000 CW R3=A+R3
10100 R4=RN(L+4)
10200 R4X=ABS(R4)
10300 R4=AMOD(R4,100.0)
10400 IF(R4X.LE.80)GO TO 50
10500 IF(R4X.GE.180)GO TO 50
10600 IF(MIN)GO TO 100
10700 C NOW MINI-NOTE
10800 CC R4=ABS(R4)-100.
10900 IF(R4.GT.80.)R4=R4-100.
11000 C MINIS MAY GO FROM 81 TO 179. NUMS < 100 ARE CONVERTED TO NUM-100.
11100 GO TO 60
11200 50 IF(MIN.EQ.0)GO TO 100
11300 CC R4=AMOD(R4,100.0)
11400 CATCH DIAMONDS, X NOTES, HEADLESS NOTES.
11500 60 R6=T*(R3-RL)
11600 R8=RLH+R6-R4
11700 C ADJUSTED STEM LENGTH
11800 IF(ISD.EQ.2)R8=-R8
11900 IF(IXD.EQ.0)GO TO 70
12000 R9=(IR7*1.571429-13.714)*RMIN
12100 R8=-R8
12200 70 IF(RN(L).LT.8)GO TO 90
12300 CHECK P10 FOR STAFF CHANGE FLAG
12400 R10=RN(L+10)
12500 IF(R10.LE.0)GO TO 90
12600 N=-1
12700 IF(R10.EQ.2)N=-N
12800 C N =-1 = ON STAFF BELOW, =1 = ABOVE.
12900 M=RS
13000 R3=ABS((STFF(M+N)-STFF(M))/(RSTJ2*7))
13100 IF(IXD)GO TO 80
13200 IF(R10.NE.ISD)R3=-R3
13300 C ABOVE FOR STEMS SAME DIR, STAFF CHNG IN SAME DIR.
13400 80 R8=R8+R3
13500 C ADDS DISTANCE TO OTHER STAFF - CONVERTED TO NOTE NUMBERS.
13600 90 IF(IXD)R8=R8+R9
13700 C IF OPPOSITE STEM DIR., SUBTRACT (2*STEM AND EXTRA BEAM SPACE)*SIZE
13800 IF(R8.LT.-5)GO TO 100
13900 C AFTER ALL THAT, IF BEAM IS TOO SMALL THEN IGNORE IT.
14000 IF(JJ2.GT.J)JJ2=J
14100 C POINT TO 1ST ITEM TO RE-DISPLAY
14200 RN(L+8)=R8
14300 R7=RN(L+7)
14400 C NEXT DELETES TAILS
14500 IF(R7.EQ.0)GO TO 100
14600 N=AMOD(R7,10.)
14700 RN(L+7)=R7-N
14800 100 CONTINUE
14900 110 CONTINUE
15000 IF(JJ2.EQ.1000)JJ2=-1
15100 END
15200
15300 SUBROUTINE SHRINK(JIT)
15400 COMMON /XRN/RN(1) /PTR/KWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX
15500 1 /ALF/A,B,C,K,M,N,MM
15600 IF(JIT.EQ.0)JIT=1
15700 MM=I
15800 DO 40 K=ITEM,JIT,-1
15900 L=KWDS(K)
16000 M=RN(L)
16100 IF(M.LE.2)GO TO 40
16200 J=M+2+L
16300 IF(RN(L+1).NE.1)GO TO 10
16400 IF(RN(L+8).EQ.0)RN(L+8)=999
16500 C NOTES MUST HAVE AT LEAST 8 PARAMS.
16600 10 DO 20 N=J,L,-1
16700 20 IF(RN(N).NE.0)GO TO 30
16800 GO TO 40
16900 30 IF(N.EQ.J)GO TO 40
17000 M=I-N
17100 CALL RLOOP(RN(N+1),RN(J+1),M)
17200 MM=J-N
17300 RN(L)=RN(L)-MM
17400 C RESET THE WDCNT.
17500 I=I-MM
17600 40 CONTINUE
17700 L=KWDS(JIT)
17800 50 JIT=JIT+1
17900 L=RN(L)+3+L
18000 C POINTER TO NEXT ITEM
18100 KWDS(JIT)=L
18200 IF(JIT.LE.ITEM)GO TO 50
18300 END
18400
18500 SUBROUTINE LULOOP
18600 COMMON /ALF/ INP(1)
18700 DO 10 K=1,72
18800 J=INP(K)
18900 IF(J.EQ.' ')GO TO 10
19000 INP(K)=J.AND..NOT.((J/2).AND."201004020100)
19100 10 CONTINUE
19200 END
19300
19400 SUBROUTINE ZCRSOR
19500 COMMON R2,JA,CENTR,J2,R3,R4,J,K,L,M
19600 DATA X/0.12/,Y/0.13/,Z/0.06/
19700 CC DATA X/1.2/,Y/1.3/
19800 CALL SETCUR(0,-300,0)
19900 IF(R2.NE.0)GO TO 20
20000 CC IF(R2.LT.99)GO TO 2
20100 CALL TYPSTR('<CR> SETS LOWER-LEFT POINT')
20200 ACCEPT 30,L
20300 CALL RDCUR(JA,J2)
20400 CALL TYPSTR('<CR> SETS UPPER-RIGHT POINT')
20500 ACCEPT 30,L
20600 CALL RDCUR(J,K)
20700 L=J-JA
20800 M=K-J2
20900 IF(L.GE.M)GO TO 10
21000 C ADD AND SUBTR. X COORDS. (MAKE THEM SAME DIST. AS Y'S)
21100 M=(M-L)/2
21200 J=J+M
21300 JA=JA-M
21400 10 L=J-JA
21500 R2=950.0/L
21600 JA=JA+L/2
21700 J2=J2+(K-J2)/2
21800 GO TO 40
21900 20 CALL TYPSTR('<CR> SETS CENTER')
22000 ACCEPT 30,L
22100 30 FORMAT(I)
22200 CALL RDCUR(JA,J2)
22300 40 CALL CLRCUR
22400 R3=JA*X+50.0
22500 R4=J2*Y+52.0
22600 K=0
22700 C (K IS R6) ↑↑↑↑↑ SO NUMS ON SPACING SCALE WILL PRINT.
22800 END
22900
23000 SUBROUTINE HELP(K)
23100 IMPLICIT INTEGER(A-Z)
23200 DIMENSION CDNUM(9)
23300 COMMON /DL/X22 /RRJJ/R(21),JJA /JCHAR/A,B,IBLA /RINP/I(16,8)
23400 1 /NUM/NUM(1)
23500 DATA CDNUM/'10','11','12','13','14','15','16','17','18'/
23600 L=-2
23700 C -2=DO LOOKUP ON MSS,MUS (HELP FILES 1→18.DMD)
23800 IF(K.NE.IBLA)GO TO 10
23900 IF(X22.EQ.0)RETURN
24000 C USE CURRENT CODE NUMBER IF IN EDIT MODE
24100 K=NUM(JJA+1)
24200 IF(JJA.GT.9)K=CDNUM(JJA-9)
24300 10 CALL GETFI2(K,L)
24400 IF(L.EQ.1)RETURN
24500 C L=1=FILE NOT FOUND
24600 L=-190
24700 CALL TYPLOC(450,L)
24800 20 CALL FASTI2(I,128)
24900 DO 40 K=1,8
25000 IF(I(1,K).EQ.999)GO TO 60
25100 DO 30 J=16,1,-1
25200 30 IF(I(J,K).NE.' ')GO TO 40
25300 J=1
25400 40 TYPE 50,(I(L,K),L=1,J)
25500 GO TO 20
25600 50 FORMAT(1X16A5/)
25700 60 CALL TYPCRLF
25800 END
25900
26000 SUBROUTINE ORDER
26100 IMPLICIT INTEGER(A-Q,S-Z)
26200 COMMON R2 /LIMIT/LIMIT,ITEM /ALF/I1
26300 1 /PTR/PWDS(1) /XRN/RN(1) /DPY/RST(1) /DPTR/WDS(1)
26400
26500 J=1
26600 CC J=4
26700 C J=4 SO FRONT OF DPY BUFFER IS UNTOUCHED.
26800 JJ=1
26900 DO 40 K=0,7
27000 10 M=0
27100 RX=9999.
27200 DO 20 L=1,ITEM
27300 N=PWDS(L)
27400 IF(R2.EQ.0.AND.K.NE.RN(N+2))GO TO 20
27500 C R2.EQ.0 = ORDER BY STAVES .NE.0 =ORDER ALL LEFT TO RIGHT
27600 R=RN(N+3)
27700 IF(R.EQ.10000.)GO TO 20
27800 C SKIP ITEM THAT WAS ALREADY SHUFFLED
27900 IF(RN(N+1).EQ.16)GO TO 30
28000 C DO NOT ORDER TEXT. (CODE 16)
28100 IF(R.GE.RX)GO TO 20
28200 RX=R
28300 M=L
28400 20 CONTINUE
28500 IF(M.EQ.0)GO TO 40
28600 C FOUND NO MORE ON THIS LINE
28700 L=M
28800 30 WDS(JJ)=J
28900 JJ=JJ+1
29000 C NOW PUT AWAY NEXT ITEM IN ORDER
29100 CC DO 3 MM=PWDS(L),PWDS(L+1)-1
29200 CC RST(J)=RN(MM)
29300 CC3 J=J+1
29400 MM=PWDS(L+1)-PWDS(L)
29500 C NEXT MOVES RN INTO RST
29600 CALL RLOOP(RST(J),RN(PWDS(L)),MM)
29700 J=J+MM
29800 RN(PWDS(L)+3)=10000.
29900 C WIPE OUT THIS POSITION
30000 GO TO 10
30100 40 CONTINUE
30200 CC DO 5 K=2,ITEM
30300 C NOW FIX UP POINTER ARRAY AGAIN
30400 CC5 PWDS(K)=WDS(K)-3
30500 C BECAUSE JJ STARTED AT =4
30600 CALL RLOOP(PWDS,WDS,ITEM)
30700 C PUTS WDS INTO PWDS
30800 CC DO 6 K=1,PWDS(ITEM+1)
30900 C AND RN ARRAY
31000 CC6 RN(K)=RST(K+3)
31100 CALL RLOOP(RN,RST,PWDS(ITEM+1))
31200 C PUT RST BACK INTO RN
31300 C SINCE DPY BUFFER WAS WIPED OUT, NOW DO A 'Z1' TO FIX IT UP.
31400 I1='Z'
31500 R2=1
31600 CALL DPYX
31700 END
31800
31900 SUBROUTINE DPYX
32000 C DOES COMPLETE DPY SETUP
32100 COMMON /DPY/ST(1)
32200 CALL DPYSET(1,ST,4000)
32300 CALL HYDPOG(2)
32400 CALL HYDPOG(1)
32500 CC CALL TYPLOC(450,0)
32600 CALL DPYBRT(5)
32700 END
32800
32900 SUBROUTINE FILX(K)
33000 C CHECKS TO SEE IF SOS OR ET FILE. IF SOS, REWRITES IT SANS #S.
33100 COMMON /ALF/I(72) /JCHAR/IXX,ISEMI,IBLA /A2Z/AA,BB,LCC,
33200 1 DD,EE,FF,GG,LHH,LII,LJJ,LKK,LEL,LMM,LNN,LOH /NUM/NZERO
33300 CALL IFILE(1,K)
33400 READ(1,50)I
33500 IF(I(1).EQ.NZERO)GO TO 70
33600 CXX **** FIX AT IRCAM 1/80 ***** IF(I(1).NE.LCC.AND.I(2).NE.LOH)GO TO 30
33700 IF(I(1).NE.LCC.OR.I(2).NE.LOH)GO TO 30
33800 C IF 1ST CHAR. IS ZERO, ASSUME IT'S AN SOS FILE
33900 C ASSUMES 'COMMENT' IF 1ST 2 CHARS ARE C AND O.
34000 20 READ(1,50)I
34100 IF(I(3).NE.ISEMI)GO TO 20
34200 C GET RID OF HEADER.
34300 READ(1,50)I
34400 C ONCE AGAIN!!
34500 RETURN
34600 30 READ(1,50,END=40)I
34700 GO TO 30
34800 C CLEAN EVERYTHING OUT.
34900 40 CALL IFILE(1,K)
35000 RETURN
35100 50 FORMAT(72A1)
35200 60 FORMAT(I,72A1)
35300 70 K='FOR21'
35400 CALL OFILE(21,K)
35500 REREAD 60,L,I
35600 CALL TYPSTR('SOS FILE COPIED TO FOR21.DAT')
35700 CALL TYPCRLF
35800 GO TO 90
35900 80 READ(1,60,END=100)L,I
36000 90 WRITE(21,50)I
36100 GO TO 80
36200 100 END FILE 21
36300 GO TO 40
36400 END
36500
36600 C*IRCAM** SUBROUTINE RREAD(I,V)
36700 C TAKES ASCII INPUT (INP) STRING, SEPARATES LETTERS FROM NUMBERS.
36800 C MAKES ALL NUMBS FLTING PT. FILLS UP END OF ARRAY WITH ZEROS.
36900 C SENDS BACK IN V ARRAY.
37000 C E.G. 'GET FOO 4.55' SENDS BACK V1=0, V2=0, V3=4.55, V4=0, ETC.
37100 C*IRCAM** DIMENSION I(1),V(1)
37200 C*IRCAM** EQUIVALENCE (N,RN)
37300 C*IRCAM** DO 62 J=1,22
37400 C ZERO V AND IV ARRAYS. (COULD BE 30 ABOVE.)
37500 C*IRCAM** 62 V(J)=0
37600 C*IRCAM** DO 6 LEND=71,1,-1
37700 C*IRCAM** 6 IF(I(LEND).NE.' ')GO TO 7
37800 C LEND=END OF CHARS. STARTS WITH NEXT-TO-LAST (LAST IS *)
37900 C*IRCAM** RETURN
38000 C*IRCAM** 7 M=1
38100 C*IRCAM** J=1
38200 C*IRCAM** 8 N=I(J)
38300 C*IRCAM** CALL LO2UP(N)
38400 C*IRCAM** IF(N.EQ.' ')GO TO 16
38500 C*IRCAM** IF(N.NE.'-'.AND.
38600 C*IRCAM** 1 N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 10
38700 C NOW IT'S A NUMBER
38800 C*IRCAM** 20 CALL NUMZ(KK,I(J),V(M))
38900 C*IRCAM** J=J+KK-1
39000 C*IRCAM** 10 M=M+1
39100 C*IRCAM** 16 J=J+1
39200 C*IRCAM** IF(J.LE.LEND)GO TO 8
39300 C*IRCAM** END
39400
39500 C*IRCAM** SUBROUTINE NUMZ(KK,I,X)
39600 C*IRCAM** DIMENSION I(1)
39700 C*IRCAM** DATA IZERO/'0'/,ININE/'9'/
39800 C*IRCAM** J=-1
39900 C*IRCAM** M=0
40000 C*IRCAM** XMINUS=1.
40100 C*IRCAM** DO 21 KK=1,15
40200 C IS 15 ENOUGH? YES, WILL DO ONLY 8 DIGITS PLUS DECI.PT.
40300 C*IRCAM** IX=I(KK)
40400 C*IRCAM** IF(IX.GE.IZERO.AND.IX.LE.ININE)GO TO 22
40500 C*IRCAM** IF(IX.EQ.'-')GO TO 24
40600 C*IRCAM** IF(IX.NE.'.')GO TO 20
40700 C*IRCAM** J=KK
40800 C*IRCAM** GO TO 21
40900 C*IRCAM** 24 XMINUS=-XMINUS
41000 C*IRCAM** GO TO 21
41100 C*IRCAM** 22 N=(IX-IZERO)/536870912
41200 C*IRCAM** M=N+M*10
41300 C*IRCAM** 21 CONTINUE
41400 C*IRCAM** 20 IF(J.LT.0)GO TO 23
41500 C*IRCAM** X=KK-J-1
41600 C*IRCAM** X=XMINUS*M/(10.**X)
41700 C*IRCAM** RETURN
41800 C*IRCAM** 23 X=XMINUS*M
41900 C FOR NO DECI.
42000 C*IRCAM** END
42100
42200 C*IRCAM** SUBROUTINE NUMLTR(L,J)
42300 C THIS, AND ABOVE ROUTINES, TAKES CARE OF STANFORD 'REREAD' FEATURE
42400 C 'RREAD' IS CALLED JUST AFTER ORIGINAL READ STATEMENT
42500 C*IRCAM** COMMON R2,JA,CEN,J2,RJQ(20) /SCM/V(22)
42600 C*IRCAM** J=V(1)
42700 C*IRCAM** N=L+1
42800 C*IRCAM** R2=V(N)
42900 C*IRCAM** DO 1 K=1,20
43000 C*IRCAM** 1 RJQ(K)=V(K+N)
43100 C*IRCAM** END